home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / msdos / dch101.zip / DCH.PAS < prev    next >
Pascal/Delphi Source File  |  1993-09-07  |  5KB  |  162 lines
  1. program Dda_CHoice_clone;
  2. {------------------------------------------------------------------------------
  3.  
  4.                                 REVISION HISTORY
  5.  
  6. v1.00  : 1993/08/25.  First public release.  DDA
  7. v1.00a : 1993/08/30.  Minor tuning of .PAS code.  DDA
  8. v1.01  : 1993/09/07.  Changed program so that user -must- press one of the
  9.                               valid keys.  Timeout will still default to
  10.                               the first though.  DDA
  11.                       The key pressed will now only be echoed if the
  12.                               user is having DCH display a message also.  DDA
  13.  
  14. ------------------------------------------------------------------------------}
  15.  
  16. uses dos, crt ;
  17. const
  18.      progdata = 'DCH- Free DOS utility: batch file query.';
  19.      progdat2 = 'V1.01: September 07, 1993. (c) 1993 by David Daniel Anderson - Reign Ware.';
  20.        usage  = 'Usage:  DCH timeout_spec keys [text]';
  21. var
  22.      timestr     : string [7];
  23.      maxtime     : longint ;
  24.      time        : word ;
  25.      timeout,
  26.      timeoutmode : boolean ;
  27.  
  28.      echoing     : boolean ;
  29.  
  30.      choices     : string ;
  31.  
  32.      selection   : char ;
  33.      errorlevel  : byte ;
  34.  
  35.      valerr      : integer ;
  36.  
  37. procedure showhelp ( errornum : byte );
  38. var
  39.     message : string [80];
  40. begin
  41.     writeln(progdata);
  42.     writeln(progdat2);
  43.     writeln;
  44.     writeln(usage);
  45.     writeln;
  46.  
  47.     case errornum of
  48.       201 : message := 'you must have at least two parameters on the command line.';
  49.       202 : message := 'timeout value must be bracketed with a "[" and a "]".';
  50.       203 : message := 'timeout value must be a number between 0 and 65535.';
  51.       204 : message := 'if you SET DCHCLR, it must be a value between 0 and 255.';
  52.     end;
  53.     writeln ( 'ERROR: (#',errornum,') - ', message );
  54.     halt ( errornum );
  55. end;
  56.  
  57. procedure settextcolor ;
  58. var colorstr : string [3] ;
  59.     colorval,
  60.     valerr   : integer ;
  61. begin
  62.     colorstr := getenv ('dchclr');
  63.     if colorstr <> '' then begin
  64.        val ( colorstr, colorval, valerr ) ;
  65.        if valerr <> 0 then showhelp (204);
  66.        if colorval > 255 then showhelp (204);
  67.        if colorval < 0 then showhelp (204);
  68.        textattr := colorval ;
  69.     end;
  70. end;
  71.  
  72. function gettext : string ;
  73. var
  74.    counter,
  75.    spaceplace : byte ;
  76.    cmdline : string ;
  77. begin
  78.    cmdline := string ( ptr ( prefixseg,$0080 )^ );
  79.     { ^^ this line courtesy of Martin Richardson ^^ }
  80.  
  81.    for counter := 1 to 3 do begin
  82.        spaceplace := ( pos ( ' ',cmdline ));
  83.        cmdline := copy ( cmdline,
  84.                        ( spaceplace + 1 ),
  85.                        ( length (cmdline) - spaceplace ) );
  86.    end;
  87.    gettext := cmdline ;
  88. end;
  89.  
  90. begin
  91.      checkbreak := false ;
  92.      if paramcount < 2 then showhelp (201);
  93.      timeout := false ;
  94.      timeoutmode := false ;
  95.      timestr := paramstr (1);
  96.  
  97.      if (( timestr [1] <> '[' )
  98.      or (( timestr [ length ( timestr ) ] )  <> ']' )) then showhelp (202);
  99.  
  100.      if length (timestr) <> 2 then begin
  101.         timeoutmode := true ;
  102.         time := 0 ;
  103.         timestr := copy ( timestr, 2, ( length ( timestr ) - 2) );
  104.         val ( timestr, maxtime, valerr ) ;
  105.         if valerr <> 0 then showhelp (203);
  106.         if  (maxtime < 0)
  107.          or (maxtime > 65535)
  108.           then showhelp (203);
  109.  
  110.         maxtime := 10 * maxtime ;
  111.         timeout := ( maxtime = 0 );
  112.      end;
  113.  
  114.      choices := paramstr (2) ;
  115.  
  116.      if paramcount > 2 then begin
  117.         echoing := true ;
  118.         settextcolor;
  119.         write ( gettext );
  120.      end ;
  121.  
  122.      if keypressed
  123.         then timeout := false ;
  124.              { so we can process a pending keystroke even }
  125.              { if the timeout parameter of [0] was used   }
  126.  
  127.      repeat
  128.          while (( not keypressed ) and ( not timeout )) do begin
  129.              delay ( 95 );
  130.                    { if delay was 100, no time would be allowed for the loop }
  131.              if timeoutmode then begin
  132.                 time := time + 1 ;
  133.                 if time >= maxtime then
  134.                    timeout := true ;
  135.              end; { if timeoutmode }
  136.          end; { while not keypressed ... }
  137.  
  138.          if not timeout then begin
  139.             selection := readkey ;
  140.             if echoing then begin
  141.                write ( selection );
  142.                gotoxy ( wherex - 1, wherey );
  143.             end;
  144.             if selection = #0 then readkey ;
  145.          end;
  146.  
  147.      until (( timeout ) or (( pos ( selection, choices )) <> 0 )) ;
  148.  
  149.      if timeout then
  150.         selection := choices [1];
  151.  
  152.      if echoing then begin
  153.         normvideo ;
  154.         writeln ;
  155.      end;
  156.  
  157.      errorlevel := ( pos ( selection , choices ) );
  158.      if errorlevel = 0 then errorlevel := 255 ;
  159.      if selection = '' then errorlevel := 0 ;
  160.      halt ( errorlevel );
  161. end.
  162.